; ORIGINAL: 3dt2.1/examples/schemers/rdrpaint.scm
;;
;; rdrpaint.scm
;;
;; Implements simple rendering and color manipulation within the context
;; of a (standard position) distant white light and a default ambient light.

;;
;; Edward C. Martin, Schemers Inc.
;; 21 December 1993
;;
(provide 'rdrpaint)

;; The following color-integer assignments are made in the file  colors.scm
;; which is loaded by the  acis.scm  file that is usually loaded at
;; initialization by the  acisinit.scm  file. Just in case this automatic
;; loading has not taken place, we load a short file of essential constants.
;;
;; (define BLACK 0)
;; (define RED 1)
;; (define GREEN 2)
;; (define BLUE 3)
;; (define CYAN 4)
;; (define YELLOW 5)
;; (define MAGENTA 6)
;; (define WHITE 7)
;;

(require 'consts "consts.scm")

;; (color:int->rgb k)  returns the RGB version of the color designated by
;; the color ID#  k,  which must be an integer in the range 0 - 7.
;;
;; modified to handle color objects, as well as, integer objects
;;
(define color:int->rgb
    (let (
        (alist (list (list BLACK   0 0 0) (list RED    1 0 0)
                     (list GREEN   0 1 0) (list BLUE   0 0 1)
                     (list CYAN    0 1 1) (list YELLOW 1 1 0)
                     (list MAGENTA 1 0 1) (list WHITE  1 1 1))))
        (lambda (k)
            (let (
                (rgb (assoc k alist)))
                (if (not rgb)
                    (error 'color:int->rgb
                            "Input is not a valid color ID number")
                    (apply color:rgb (cdr rgb))
                    )
                )
            )
        )
    )

;; (rgb clr-name-string)  returns the RGB version of the Windows 16-color
;; VGA color named by  clr-name-string,  which must be one of the following:
;;
;; "black"   "maroon"   "darkgreen"   "olive"   "navy"   "purple"
;; "teal"    "gray"     "silver"      "red"     "green"  "yellow"
;; "blue"    "magenta"  "cyan"        "white"
;;
;; all in lower-case letters.
;;
(define rgb
  (let ((alist
          (list (list "black" 0 0 0) (list "maroon" 0.5 0 0)
                (list "darkgreen" 0 0.5 0) (list "olive" 0.5 0.5 0)
                (list "navy" 0 0 0.5) (list "purple" 0.5 0 0.5)
                (list "teal" 0 0.5 0.5) (list "gray" 0.5 0.5 0.5)
                (list "silver" 0.75 0.75 0.75) (list "red" 1 0 0)
                (list "green" 0 1 0) (list "yellow" 1 1 0)
                (list "blue" 0 0 1) (list "magenta" 1 0 1)
                (list "cyan" 0 1 1) (list "white" 1 1 1))))
    (lambda (clr-name-string)
      (let ((clr (assoc clr-name-string alist)))
        (if (not clr)
            (error 'rgb "Input is not a valid color name string")
            (apply color:rgb (cdr clr)))))))

;; (paint k) returns a standard material entity whose color property is
;; specified by the given color ID number, which must be an integer in
;; the range 0 - 7.
;;
(define paint
    (let (
        (black-paint   (material)) (red-paint    (material))
        (green-paint   (material)) (blue-paint   (material))
        (cyan-paint    (material)) (yellow-paint (material))
        (magenta-paint (material)) (white-paint  (material)))

        (for-each
      (lambda (pnt clr-int)
        (material:set-color-prop pnt "color" (color:int->rgb clr-int)))
      (list black-paint red-paint green-paint blue-paint
            cyan-paint yellow-paint magenta-paint white-paint)
      (list BLACK RED GREEN BLUE CYAN YELLOW MAGENTA WHITE))
    (let ((alist
            (list (cons BLACK black-paint) (cons RED red-paint)
                  (cons GREEN green-paint) (cons BLUE blue-paint)
                  (cons CYAN cyan-paint) (cons YELLOW yellow-paint)
                  (cons MAGENTA magenta-paint) (cons WHITE white-paint))))
      (lambda (clr-int)
        (let ((mat (assoc clr-int alist)))
          (if (not mat)
              (error 'paint "Input is not a valid color ID number")
              (cdr mat)))))))


;; (entity:paint ent clr-int)  assigns to the input entity  ent  a material
;; entity whose color property is given by the input color ID number. The
;; return value is unspecified.
;;
(define entity:paint
  (lambda (ent clr-int)
    (entity:set-material ent (paint clr-int))))

;; Create a (standard position) distant white light.
;;
(define Dlight
  (let ((L (light "distant")))
    (light:set-prop L "location" (gvector 3 -1.5 5))
    L))

;; Create an ambient white light.
;;
(define Alight
  (let ((L (light "ambient")))
    (light:set-prop L "intensity" 0.2)
    L))

;; Use  Alight  and  Dlight  as the lights for rendering purposes.
;;
(light:set #t (list Alight Dlight))

;; Create a default plain background, and use it as the rendering
;; background.
;;
(define Bground (background "plain"))

(render:set-background Bground)

;; A standard filter utility used in the following definition.
;;
;; (filter test? lst)  returns the sub-list of the input  lst  that
;; pass the input  test? .
(define filter
  (lambda (test? lst)
    (letrec ((loop
               (lambda (rest)
                 (cond
                   ((null? rest) '())
                   ((test? (car rest)) (cons (car rest) (loop (cdr rest))))
                   (else (loop (cdr rest)))))))
      (loop lst))))

;; Provide a name for the collection of the above light, material, and
;; background entities. This may come in handy later on if you want to clear
;; the part except for these basic entities. (Uses a filter utility defined
;; above. We cannot use entity-filters here because "light?", etc. are not
;; acceptable inputs to  filter:type.)
;;
(define paint-etc
  (filter
    (lambda (ent)
      (or (background? ent) (light? ent) (material? ent)))
    (part:entities)))

;; Example:
;; (define S (solid:block (position -20 -20 -20) (position 20 20 20)))
;; (entity:paint S RED)
;; (define B (solid:sphere (position 30 -30 30) 10))
;; (entity:paint B YELLOW)
;; (render)

;; end of file  rdrpaint.scm
